home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / DNET / DNET.lisp < prev   
Encoding:
Text File  |  1990-06-24  |  71.1 KB  |  1,523 lines  |  [TEXT/MACA]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;
  15. ; File:         DNET.LISP
  16. ; Author:       Dan Suthers
  17. ; Created:      10-Apr-88 01:48:11
  18. ; Modified:     22-Jun-90 02:31:07 (Dan Suthers)
  19. ; Language:     LISP
  20. ; Package:      DNET
  21. ;
  22. ; Description:  Simple discrimination net for uniquifying list expressions
  23. ;               and associating information with those expressions.
  24. ;               Includes pattern matching and context switching mechanisms.
  25. ;
  26. ; (c) Copyright 1988, by Daniel D. Suthers
  27. ;                        Department of Computer and Information Science
  28. ;                        University of Massachusetts
  29. ;                        Amherst, Massachusetts 01003
  30. ;
  31. ; This software was conceived, designed, and written by Dan Suthers 
  32. ; while supported by the National Science Foundation under grant number
  33. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  34. ; CA.  Partial support was also received from the Office of Naval Research
  35. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  36. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  37. ; the above grants and encouraged me to pursue my own research interests in
  38. ; her lab.  This work would not have been possible without the resources and
  39. ; stimulating environment of the Computer and Information Science department.
  40. ;
  41. ; Permission to use, modify, and distribute this software is granted subject 
  42. ; to the following restrictions and understandings:
  43. ; 1. The file header, including this notice, shall be retained, and may be
  44. ;    extended to include documentation of modifications to the software.
  45. ; 2. This material is for nonprofit educational and research purposes only.
  46. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  47. ;    noteworthy uses of this software.
  48. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  49. ;    representation that the operation of this software will be error free,
  50. ;    and are under no obligation to provide any services.
  51. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  52. ;    Suthers and the University of Massachusetts from all claims arising 
  53. ;    out of the use or misuse of this software, or arising out of any 
  54. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  55. ;    fees, and liabilities incurred in or about any such claim, action, or
  56. ;    proceeding brought thereon.
  57. ; 5. All materials and reports developed as a consequence of the use of 
  58. ;    this software shall duly acknowledge such use, in accordance with
  59. ;    the usual standards of acknowledging credit in academic research.
  60. ;
  61. ; Status:       Stable and well tested.
  62. ;
  63. ; Tested:       Hewlett Packard 9000       02-Nov-88 Dan Suthers
  64. ;               Macintosh II Coral/Allegro 20-Apr-89 Dan Suthers
  65. ;               Texas Instruments Explorer 02-Nov-88 Dan Suthers
  66. ;               VAX/VMS                    20-Apr-89 Dan Suthers
  67. ;
  68. ; Changes:      
  69. ;   25-Jun-88 Type checking, type declarations, and optimizing.
  70. ;   30-Jun-88 New-expr-hook now specific to each dnet.
  71. ;   02-Jul-88 BIND conflicts with TI compiler; renamed to BIND-VARS.
  72. ;   13-Jun-88 Update to new version of SM.
  73. ;   15-Jun-88 Added SUBSTITUTE-VARS.
  74. ;   20-Jul-88 SAVE-DNET now saves with the explicit name; no *dnet*.
  75. ;     Dotted lists checked for by INDEXPR, since we optimize out any
  76. ;     type checking once past the argument checking.  Dnet-Terminals
  77. ;     no longer in SM.
  78. ;   30-Jul-88 DNET-ROOT -> DNET (this was an artifact); DNET-TERMINALS
  79. ;    eliminated to save space; INDEXPR-HOOK and DELEXPR-HOOK instead of
  80. ;    NEW-EXPR-HOOK; changes to MAKE-DNET syntax; VARIABLE -> DEFVARIABLE;
  81. ;    proclamations.
  82. ;  01-Nov-88 Update to reflect SM changes.
  83. ;  16-Nov-88 Added MATCH and UNIFY; made optimize declarations better;
  84. ;    made internal versions of functions that don't check args.
  85. ;  20-Nov-88 MATCH-PATTERN handles &rest "dotted variables": (a b . ?:x);
  86. ;    match-x-internal takes previous-bindings argument (for client's sake).
  87. ;  24-Nov-88 Added MAP-DNET-TERMINALS.
  88. ;  10-Dec-88 Added RESET-DNET; SAVE-DNET now finds variables in INFO too.
  89. ;  17-Dec-88 ? package now does not use any other package, so symbols in
  90. ;    package LISP won't screw it up when declared as variables in ?.
  91. ;    DEFVARIABLE now takes strings as well as symbols.  
  92. ;  23-Dec-88 SUBSTITUTE-VARS renamed SUBSTITUTE-BINDINGS.  Added version
  93. ;    called SUBSTITUTE-TRANSITIVE-BINDINGS for ((?:x . 3) (?:y . ?:x)). 
  94. ;  16-Jan-89 SAVE-DNET uses INDEXPR-INTERNAL for faster load.
  95. ;  22-Mar-89 Added PATTERN-P; Made UNIFY and MATCH return 3 values to 
  96. ;    separate the bindings in each direction.
  97. ;  24-Nov-89 Updating documentation only.
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99. ; 
  100. ;                          USER'S DOCUMENTATION
  101. ;
  102. ;  A discrimination net facility lets one do several things:
  103. ;
  104. ;  - 'Uniquify' list expressions under EQ by allowing one to retrive a stored
  105. ;    expression using an EQUAL expression as the key.
  106. ;  - Associate properties with list expressions (using the above capability).
  107. ;  - Ask whether a particular expression has been stored in a data base.
  108. ;  - Retrieve expressions by pattern matching using variables in either the
  109. ;    retrieval key or in the stored expressions.
  110. ;  - Change contexts efficiently by changing the discrimination net in use.
  111. ;
  112. ;  A discrimination net may be used to implement a simple data base, or to
  113. ;  support more sophisticated systems for deductive retrieval, forward and
  114. ;  backward chaining of rules, and/or truth maintenance.  The present package
  115. ;  attempts to be simple, general, and efficient by providing the most basic
  116. ;  operations efficiently implemented without frills.
  117. ;
  118. ;  Most operations take the discrimination net as their last argument.  This
  119. ;  facilitates context switching.  Storage of dotted lists is not allowed, 
  120. ;  due to the indexing method used.  Pattern matching retrieval processes 
  121. ;  variables in either the query pattern (MATCH-PATTERN) or the network 
  122. ;  (MATCH-EXPRESSION), or both (MATCH). The general MATCH function is less 
  123. ;  efficient, and most applications only need to match in one direction.
  124. ;
  125. ;  When a new expression is added via INDEXPR, some applications will need 
  126. ;  to do special processing of the expression and/or its dnet-terminal.  If 
  127. ;  this were left to the application after the INDEXPR call returned, this 
  128. ;  processing could not be done on expressions loaded from a file saved by 
  129. ;  SAVE-DNET, since the latter writes calls to INDEXPR with no surrounding 
  130. ;  application-specific forms.  The solution is to have an INDEXPR-HOOK, 
  131. ;  which when non-nil is a lambda called on all newly indexed expressions 
  132. ;  and their dnet-terminals.  There is also a corresponding DELEXPR-HOOK.
  133. ;
  134. ; Discrimination Net Operations:  
  135. ;    MAKE-DNET makes new ones.
  136. ;    RESET-DNET resets to empty and modifies associated info.
  137. ;    DNET-INFO associates information with a dnet.
  138. ;    ALL-EXPRESSIONS returns all expressions in a dnet (slow).
  139. ;    MAP-DNET-TERMINALS maps a function across all dnet-terminals in a dnet.
  140. ;    DESTROY-DNET undefines and deallocates a dnet.
  141. ;    SAVE-DNET saves a dnet to a file (slow).
  142. ;  (Functions requiring retrieval of all expressions are slow because DNET is
  143. ;  optimized for balancing fast access to single expressions with space economy.)
  144. ; 
  145. ; Expression-Based Operations:
  146. ;  These do not process variables (treat variables like any other atom).
  147. ;   INDEXPR puts an expression in a dnet.
  148. ;   GETEXPR retrieves an expression from a dnet.
  149. ;   DELEXPR deletes an expression from a dnet.
  150. ;   EXPR-INFO associates information with an expression in a dnet.
  151. ;
  152. ; Pattern-Based Operations:
  153. ;  A pattern is a symbolic expression which may contain variables.  
  154. ;  Variables are symbols in the package ?.  It is recommended that
  155. ;  one declare all variables before use with the (defvariable <sym>) form.
  156. ;  No symbol should ever be uninterned from ? by another program.
  157. ;   DEFVARIABLE defines a variable.
  158. ;   VARIABLE-P tests whether an object is a variable. 
  159. ;   PATTERN-P tests whether an object is an expression containing a variable.
  160. ;   VARIABLES-IN-PATTERN returns a list of variables in a pattern.
  161. ;   MATCH retrieves patterns (or expressions) matching a given pattern (expression).
  162. ;   MATCH-PATTERN retrieves expressions matching a given pattern.
  163. ;   MATCH-EXPRESSION retrieves patterns matching a given expression.
  164. ;   BIND-VARS does the variable binding (restricted unification) for one-way
  165. ;     match candidates, and is exported for its potential usefulness.
  166. ;   UNIFY does bidirectional variable binding (for MATCH), and is exported.
  167. ;   SUBSTITUTE-BINDINGS substitutes for variables in a pattern to give an
  168. ;     expression, given a binding list.
  169. ;
  170. ; NOTE ON BEHAVIOR -- The following behavior is CORRECT:
  171. ;
  172. ;   ? (dnet:make-dnet :test-dnet)
  173. ;   ? (dnet:indexpr '(a b c) :test-dnet)
  174. ;   ? (dnet:indexpr '(a ?:x c) :test-dnet)
  175. ;   ? (dnet:indexpr '(a ?:y c) :test-dnet)
  176. ;   ? (dnet:indexpr '(a (?:x y z) c) :test-dnet)
  177. ;
  178. ;   ? (dnet:match-pattern '(a ?:x c) :test-dnet)
  179. ;   ((A (?:X Y Z) C) (A ?:Y C)     (A ?:X C)     (A B C))
  180. ;   (((?:X ?:X Y Z)) ((?:X . ?:Y)) ((?:X . ?:X)) ((?:X . B)))
  181. ;
  182. ;   ? (dnet:match-expression '(a ?:x c) :test-dnet)
  183. ;   ((A ?:X C)     (A ?:Y C))
  184. ;   (((?:X . ?:X)) ((?:Y . ?:X)))
  185. ;
  186. ;   ? (dnet:match '(a ?:x c) :test-dnet)
  187. ;   ((A ?:Y C)    (A ?:X C) (A B C))
  188. ;   (((?:X . ?:Y)) NIL      ((?:X . B)))
  189. ;   (NIL           NIL      NIL)
  190. ;
  191. ; MATCH-PATTERN ignores variables in the DNET.  Thus, (?:X Y Z) is a
  192. ;   constant list as far as it is concerned, and there is no contradiction
  193. ;   to binding ?:X to (?:X Y Z).  This feature may be useful when trying
  194. ;   to retrieve patterns without processing their variables.
  195. ; MATCH-EXPRESSION treats the ?:x in the query as a constant, so only
  196. ;   returns the patterns in the DNET which match it.  One happens to have
  197. ;   a variable which is the same as the constant; the other matches the
  198. ;   variable ?:y in DNET to the constant ?:x.
  199. ; MATCH will only return patterns which logically unify with the query
  200. ;   pattern.  Thus, it is correctly more restrictive than MATCH-PATTERN
  201. ;   above, as ?:X cannot be bound to an expression containing itself.
  202. ;   While MATCH returns bindings in both directions (the second and third
  203. ;   values), (?:Y . ?:X) does not appear in the second binding list for
  204. ;   (A ?:Y C) because (?:X . ?:Y) already expressed the binding, "using 
  205. ;   up" ?:Y.  I.e., there is no redundancy across the binding lists.
  206. ;
  207. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  208. ;
  209. ;                          Implementation Notes
  210. ; 
  211. ; The implementation relies on the SM package, which contains a Structure
  212. ; manager for Common Lisp structures.  Discrimination nets are implemented
  213. ; as SM objects of type DNET, and the data structures in which expressions
  214. ; are stored use CL structures of type DNET-TERMINAL.  While DNET may be used
  215. ; by client programs ignorant of SM, it provides access to these SM objects 
  216. ; in a manner which a SM-knowledgable client may use to increase efficiency.
  217. ;
  218. ; This version uses nested association lists to represent the discrimination
  219. ; net.  This network will be quite big if printed, so this should be avoided.
  220. ; Use of an SM object name to identify DNETs prevents printing the network 
  221. ; inadvertently when tracing function calls.
  222. ;
  223. ; Each DNET has a LINK slot containing the discrimination net.  An INFO slot
  224. ; allows the client program to record related information.
  225. ;
  226. ; Terminals in the network are CL structures of type DNET-TERMINAL.  The EXPR
  227. ; slot gives the expression indexed, and the INFO slot is used by the client
  228. ; to associate properties with the expression. These are represented as vector
  229. ; structures for efficiency, and they are un-named for economy of space.
  230. ;
  231. ; Why don't I just store the INFO at the terminal, and not bother saving the
  232. ; EXPR, which presumably we already know anyway by virtue of having found a 
  233. ; path to the terminal?  The pattern matchers, which may reach a multitude of 
  234. ; terminals via variable matching, have to return all the expressions which 
  235. ; got them there.  The matching code is much easier to write if it doesn't 
  236. ; have to keep track of how it got to the terminal in order to cons up and 
  237. ; return the expression corresponding to the path traversed.  By storing the 
  238. ; expression, we avoid having to cons up a new version of it every time its 
  239. ; terminal is reached.  So at a small space penalty the code is simpler, 
  240. ; faster, and costs less garbage collection.
  241. ;
  242. ; ----------------------------------
  243. ; Traversing the Discrimination Net:
  244. ;
  245. ; At any given time we need a handle on a place in the dnet which allows us
  246. ; to add new branches.  The fundamental unit is called a LINK, and consists
  247. ; of a cons of the key that got us to where we are and the association list
  248. ; which takes us out of where we are: 
  249. ;               (key . ((k1 . ...) ... (kn . ....))).
  250. ; In most of the code, if a function is called with the above link, it may
  251. ; assume that we have already "consumed" the <key>, and the association list
  252. ; in the cdr represents the branches in the dnet which may be taken.
  253. ; Traversal of a link consists of selecting one of the (ki . ...) items to
  254. ; become the new link.  Since each function sees the entire link, it can 
  255. ; push new items onto or replace its alist.
  256. ;
  257. ; -----------------
  258. ; Pattern Matching:
  259. ;
  260. ; Pattern matching works by first retrieving candidate matches by processing
  261. ; variables without checking consistency of bindings, then checking this
  262. ; consistency with a unifier or partial unifier.  (Only MATCH uses the more
  263. ; expensive full unifier.)  The reasons for taking this simple approach, 
  264. ; rather than doing retrieval and unification all at once, are:
  265. ; 1. Code Complexity: Recording bindings dictates continuation in recursive 
  266. ;    call with extended binding list.  But continuing at a continuation link
  267. ;    after consuming an item requires that we know what followed a variable;
  268. ;    i.e. works best after we have returned from the recursive call that
  269. ;    consumed items.  A possible solution is to continue in recursive calls,
  270. ;    but add a parameter passed the list the variable was found in, but ...
  271. ; 2. Space: To record bindings so they may be checked and returned, you must
  272. ;    cons up their bindings to the relevant subexpressions, and save these
  273. ;    in an alist. Many of these consed bindings will fail.  In contrast, the
  274. ;    approach implemented here conses up only bindings very likely to succeed.
  275. ; 3: Speed: Solutions to 1 will probably require more parameter passing, or
  276. ;    some other speed tradeoff which reduces gain over re-processing the
  277. ;    expressions in BIND-VARS.  Garbage Collection is increased by 2.
  278. ;
  279. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  280. ;
  281. ;                           Possible Improvements
  282. ;
  283. ; Specialized Unification for Speed:
  284. ;
  285. ; * Determine what has already been verified by the MATCH- internal functions,
  286. ;   and modify UNIFY to take advantage of this.  We loose export of general 
  287. ;   purpose UNIFY (without loss of logical generality), but gain efficiency.
  288. ;
  289. ; COMMENT: I did this for the match-X functions, but not for MATCH.
  290. ;
  291. ; Variable Uniqueness:
  292. ;
  293. ; Come to a decision on the variable uniqueness issue -- are variables
  294. ; assumed to be unique between expressions by not writing code which deals
  295. ; with the case when they are not, *forced* to be by writing code to treat
  296. ; the same ? symbol in different expressions as different, or do I write
  297. ; a more general unifier?  Not sure if this will help anything.
  298. ;
  299. ; DNET Optimization:
  300. ;
  301. ; The next two ideas have to do with ways to optimize the space/time 
  302. ; performance of DNETs.  I don't plan on on-line transformations because 
  303. ; it would be too expensive to decide if they are needed every time we
  304. ; do an insertion or deletion.  Instead, a single function, called 
  305. ; OPTIMIZE-DNET, could perform the desired transformations based on the
  306. ; current contents of the DNET, and could be called by the user after
  307. ; loading a static DNET, or periodically or after major changes.
  308. ; 
  309. ; * Hash Tables for Speed:
  310. ;   - Modify the DNET functions to use either hash tables or alists depending
  311. ;     on which is found in the CDR of a link. 
  312. ;   - Then write a routine that recasts all a-lists above a certain length as 
  313. ;     hash tables.  (Hash tables are empirically faster for even tables/lists 
  314. ;     of 3 in CCL.  However, CCL and the HP both have a minimum table size of 
  315. ;     37, which should be considered when deciding at what threshold to 
  316. ;     convert.
  317. ;
  318. ; COMMENT: I tried this.  Unfortunately the minimum hash table size makes 
  319. ; this a space-hog.  Worse, speed tests showed the mixed representation
  320. ; was SLOWER, presumably because one must test at each link for whether 
  321. ; a hash table or alist is used.  I wanted to test a pure hash table 
  322. ; representation, but ran out of memory under this rep (in 4 meg). 
  323. ;
  324. ; * Compressing Linear Paths for Space Reduction:
  325. ;   - Come up with a representation for linear paths, eg. a distinguishable
  326. ;     CDR object in the links.
  327. ;   - Modify search and deletion functions to use it.
  328. ;   - Write a transformation routine for compression. 
  329. ;   - Note that here we must violate strict off-line transformations: an
  330. ;     insertion may force decompression of a (formerly) linear path.
  331. ;
  332. ; Child DNETs for Context Hierarchies:
  333. ;
  334. ; Implement a facility where a DNET may have children who inherit the
  335. ; expressions in the parent DNET during retrieval.  Insertion occurs
  336. ; in the specified DNET only.  (Perhaps assume the child does not exist
  337. ; independent of the parent, so insertion into child occurs only if the
  338. ; expression is not already in the parent.  But expressions not in the
  339. ; parent can be inserted into either parent or child.)
  340. ;
  341. ; TMS:
  342. ;
  343. ; Write additional code in a separate file that implements a TMS, using
  344. ; the EXPR-INFO to store justifications and INDEXPR/DELEXPR-HOOKs to 
  345. ; do the truth maintenance.
  346. ;
  347. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  348.  
  349. (in-package :DNET)
  350.  
  351. (export '(
  352.  
  353.           *?-package*
  354.           *dnet-package*
  355.  
  356.           ;; For dnets
  357.  
  358.           all-expressions
  359.           destroy-dnet
  360.           dnet-info
  361.           make-dnet
  362.           map-dnet-terminals
  363.           reset-dnet
  364.           save-dnet
  365.  
  366.           ;; For expressions
  367.  
  368.           delexpr
  369.           getexpr
  370.           indexpr
  371.           expr-info
  372.           not-a-dotted-list
  373.  
  374.           ;; Pattern matching
  375.  
  376.           bind-vars
  377.           defvariable
  378.           match
  379.           match-expression
  380.           match-pattern
  381.           pattern-p
  382.           substitute-bindings
  383.           substitute-transitive-bindings
  384.           unify
  385.           variable-p
  386.           variables-in-pattern
  387.  
  388.           ;; For clients wishing to access internal SM representations:
  389.  
  390.           dnet
  391.           dnet-info-place
  392.           dnet-delexpr-hook
  393.           dnet-indexpr-hook
  394.           dnet-compiled-delexpr-hook
  395.           dnet-compiled-indexpr-hook
  396.           dnet-terminal-expr
  397.           dnet-terminal-info
  398.  
  399.           ))
  400.  
  401. (require :MAPPINGS)
  402. (require :SM)
  403.  
  404. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  405. ;;; OPTIMIZING IN ...
  406. ;;; ----------------
  407. ;;; CORAL'S ALLEGRO:
  408. ;;; - The safety 1 space 2 speed 2 setting lets the compiler trust all
  409. ;;; type declarations, and eliminates event-processing in iterative loops.
  410. ;;; - We crank this up to safety 1 space 2 speed 3 for heavy computation,
  411. ;;; so fixnum operations are guaranteed to return fixnums, and car and
  412. ;;; cdr don't check types (but an error would crash Allegro).
  413. ;;; - A drop to safety 0 would eliminate number of argument and stack 
  414. ;;; overflow checks, skip some event processing, and make slot access 
  415. ;;; open coded with no type checking. Risky.
  416. ;;; -----------------
  417. ;;; HP's Common Lisp:
  418. ;;; Only safety and speed are used.  This only affects compiled code.
  419. ;;; - Safety 0 supresses argument count check.
  420. ;;; - Speed 2 does constant folding, "safe tranforms" on function calling,
  421. ;;; conversion of &rest and &keyword to positional, and open coding where declared.
  422. ;;; - Speed 3 supresses argument count check (as if safety 0); makes structure slot
  423. ;;; access and setf inline with no checking; and additional functional transforms.
  424.  
  425. (proclaim '(optimize (safety 1) (space 2) (speed 2)))
  426.  
  427. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  428. ;;;
  429. ;;;                         DATA STRUCTURES
  430. ;;;
  431. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  432.  
  433. (deftype boolean () '(or T null))
  434.  
  435. (defstruct (DNET-TERMINAL (:type vector) ; don't waste space with label
  436.                           (:constructor make-dnet-terminal (expr info)))
  437.   (EXPR nil :type T :read-only t)
  438.   (INFO nil :type T :read-only nil))
  439.  
  440. (defparameter *DNET-PACKAGE* (find-package "DNET"))
  441.  
  442. ;;; CCL Belched without this eval-when.
  443.  
  444. (eval-when (eval load compile)
  445.   (defparameter *?-PACKAGE* (or (find-package "?") (make-package "?")))
  446.   ;;; Need to un-use all packages (eg LISP) so a symbol declared as a variable 
  447.   ;; in ? will indeed be a symbol in ?, and hence treated as a variable.
  448.   (unuse-package (package-use-list *?-package*) *?-package*))
  449.  
  450. (sm:dst (DNET
  451.          (:reusable nil)
  452.          (:sort-instances t)
  453.          (:comments "
  454.   Discrimination NETwork root node, which provides a handle on an entire DNET.
  455.   Discrimination networks are used to manage a database of arbitrary list and
  456.   symbol expressions, and do retrieval using pattern matching on expressions 
  457.   with variables in them: see documentation in the source file.  Instances are
  458.   not reusable since there are many conses in the LINK slot to be reclaimed.  
  459.   DNETs saved to a file by SM:PRINTS will be empty when loaded: use SAVE-DNET."))
  460.  
  461.         (LINK      (list :head)
  462.                    :type list 
  463.                    :computed t
  464.                    :comments "
  465.     This slot contains the entire discrimination network, in the form of a nested
  466.     association list (can be large).  Called a link since, like all its recursive
  467.     components, it consists of a cons of a key (in this case, the name of the DNET)
  468.     and a list of other links (consequently, an alist).")
  469.  
  470.         (INDEXPR-HOOK nil
  471.                       :type list
  472.                       :comments "
  473.     If non-NIL, contains a lambda form.  The first time an expression is indexed
  474.     into the DNET, if this is non-nil its compiled version (see next slot) is 
  475.     called on two arguments: the expression, and its dnet-terminal structure.")
  476.  
  477.         (COMPILED-INDEXPR-HOOK 
  478.          nil
  479.          :type (or null function)
  480.          :computed T
  481.          :comments "
  482.     If non-NIL, contains the compiled functional version of the lambda form 
  483.     stored in INDEXPR-HOOK.")
  484.  
  485.         (DELEXPR-HOOK nil
  486.                       :type list
  487.                       :comments "
  488.     If non-NIL, contains a lambda form.  When an expression is successfully
  489.     deleted from the DNET, if this is non-nil its compiled version (see next slot)
  490.     is called on two arguments: the expression, and its dnet-terminal structure.")
  491.  
  492.         (COMPILED-DELEXPR-HOOK 
  493.          nil
  494.          :type (or null function)
  495.          :computed T
  496.          :comments "
  497.     If non-NIL, contains the compiled functional version of the lambda form 
  498.     stored in DELEXPR-HOOK.")
  499.  
  500.         (INFO-PLACE nil 
  501.                     :type T
  502.                     :comments "
  503.     The user may associate arbitrary information with the DNET by storing it 
  504.     in this slot, SETF accessable using DNET-INFO."))
  505.  
  506. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  507. ;;;
  508. ;;;                     INTERNAL FUNCTIONS AND MACROS
  509. ;;;
  510. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  511. ;;; Many of these are not needed by the user. To save space, the macros 
  512. ;;; are not loaded in compiled files.
  513.  
  514. (defun NOT-A-DOTTED-LIST (expr)
  515.   "not-a-dotted-list <expr>                                        [Function]
  516.   Returns T iff there is no non-nil atomic CDR in <expr>."
  517.   (declare (optimize (safety 1) (space 2) (speed 3)))
  518.   (cond ((null expr) T)
  519.         ((atom expr) T)
  520.         ((and (cdr expr) (atom (cdr expr))) nil)
  521.         (t (and (not-a-dotted-list (car expr))
  522.                 (not-a-dotted-list (cdr expr))))))
  523.  
  524. ;;; Basic link operations.
  525. (eval-when (compile eval)
  526.   
  527.   (defmacro TRAVERSE-LINK (key link)
  528.     ;; The cdr is the association list.
  529.     `(assoc ,key (cdr ,link) :test #'equal)) ; (the list (cdr ,link)) but CCL has bug
  530.   
  531.   (defmacro ADD-LINK (key link)
  532.     ;; Must return the link just created (not the link it is added to),
  533.     ;; so construction may continue from the returned result.
  534.     `(or (assoc ,key (cdr ,link) :test #'equal)  ; (the list (cdr ,link)) but CCL has bug
  535.          (let ((newlink (cons ,key nil)))
  536.            (declare (cons newlink))
  537.            (push newlink (cdr ,link))  ; (the list (cdr ,link)) but CCL has bug
  538.            newlink)))
  539.   )
  540.  
  541. ;;;------------------------------------------
  542. ;;; Finding the node of something in the net.
  543.  
  544. ;;; This is not eval-when eval compile because EXPR-INFO-INTERNAL, used by other
  545. ;;; DNET files, expands into a form which contain this.  So it needs to be loaded.
  546.  
  547. (defmacro FIND-TERMINAL-LINK (expr link)
  548.   `(cond ((null ,link) nil)
  549.          ((atom ,expr) (traverse-link ,expr ,link))   ; nil caught here ...
  550.          ((list-find-terminal-link ,expr ,link))))    ; so never passed here ...
  551.  
  552. (defun LIST-FIND-TERMINAL-LINK (list link)
  553.   (declare (list list link) (optimize (safety 1) (space 2) (speed 3)))
  554.   (do ((lptr list (cdr lptr))
  555.        (curlink (traverse-link :begin-list link)))
  556.       ((null lptr) (traverse-link :end-list curlink)) ; relies on list never nil
  557.     (declare (list lptr curlink))
  558.     (if (null curlink) (return nil))
  559.     (setf curlink (find-terminal-link (car lptr) curlink))))
  560. (proclaim '(function list-find-terminal-link (list list) list))
  561.  
  562. ;;;----------------------------------------------
  563. ;;; Inserting links to a new terminal in the net.
  564.  
  565. (eval-when (compile eval)
  566.   (defmacro LINK-TO-TERMINAL (expr link)
  567.     `(if (atom ,expr)
  568.        (add-link ,expr ,link)
  569.        (list-link-to-terminal ,expr ,link))))
  570.   
  571. (defun LIST-LINK-TO-TERMINAL (list link)
  572.   ;; Iterates down list adding items.
  573.   (declare (list list link) (optimize (safety 1) (space 2) (speed 3)))
  574.   (do ((lptr list (cdr lptr))
  575.        (curlink (add-link :begin-list link)))
  576.       ((null lptr) (add-link :end-list curlink))
  577.     (declare (list lptr curlink))
  578.     (setf curlink (link-to-terminal (car lptr) curlink))))
  579. (proclaim '(function  list-link-to-terminal (list list) list))
  580.  
  581. ;;;-----------------------------------------
  582. ;;; Deleting links to a terminal in the net.
  583.   
  584. ;;; Returns DNET-TERMINAL structure (not link) if it was there.  Removes links
  585. ;;; which are no longer needed.  That is, removes that sub-branch of the tree
  586. ;;; which ends in the terminal and is linear (has no branches other than the
  587. ;;; links to the terminal).
  588.  
  589. (eval-when (compile eval)
  590.   (defmacro UNLINK-RETURNING-TERMINAL (expr link)
  591.     ;; Use of *terminal* and catch/throw simplifies the recursive function.
  592.     `(let ((*terminal* nil))
  593.        (declare (special *terminal*) (atom *terminal*))
  594.        (catch :not-found 
  595.          (unlink-using-token-list (list-of-tokens ,expr) ,link)
  596.          *terminal*))))
  597.   
  598. ;; This was difficult to write until I resorted to using a list of tokens.
  599. ;; Now the pattern is simple.  The tokens direct tree traversal. Two base 
  600. ;; conditions: failure (throw to bypass return code) or success (record the
  601. ;; terminal and initiate pruning). Else, recurse on the next link, then 
  602. ;; determine if that link is to be pruned by seeing if its subtree was. A
  603. ;; linear branch has the property that if you delete a link, the enclosing
  604. ;; alist goes to nil, since it only had one link in it (was linear).  Thus
  605. ;; a test of whether the alist of the link is nil determines whether to 
  606. ;; prune it, assuming the recursive pruning was done correctly in the link.
  607.   
  608. (defun UNLINK-USING-TOKEN-LIST (tokens link)
  609.   (declare (special *terminal*) (list tokens link) 
  610.            (optimize (safety 1) (space 2) (speed 3)))
  611.   (cond
  612.    ;; Failure: bypass return code.
  613.    ((null link) (throw :not-found nil))
  614.    
  615.    ;; We have consumed the original expression. If success, save the terminal,
  616.    ;; and initiate pruning by setting the alist of the link to nil.  (This meets
  617.    ;; the assumption of the tests for linearity to be made on the way back up.)
  618.    ((null tokens)
  619.     (if (not (atom (cdr link))) (throw :not-found nil)) ; atom = dnet-terminal
  620.     (setf *terminal* (cdr link))
  621.     (setf (cdr link) nil))
  622.    
  623.    ;; Still more traversing to do.  Traverse the next token/link; recurse
  624.    ;; from there; and prune the branch if it is linear on return.  Test the
  625.    ;; latter condition by seeing if it has a null alist.
  626.    ((let ((next-link (traverse-link (car tokens) link))) ; next place
  627.       (declare (list next-link))
  628.       (unlink-using-token-list (cdr tokens) next-link)   ; recursive work
  629.       (if (null (cdr next-link))                         ; now prune if linear
  630.         (setf (cdr link) (delete next-link (cdr link))))))))
  631. (proclaim '(function unlink-using-token-list (list list) list))
  632.  
  633. (defun LIST-OF-TOKENS (expr)
  634.   ;; Constructs a list of atoms or :begin-list and :end-list keywords
  635.   ;; which uniquely encodes the expression.  These are the keys used
  636.   ;; to index in a discrimination net down to the corresponding terminal.
  637.   (declare (optimize (safety 1) (space 2) (speed 3)))
  638.   (cond 
  639.    ((atom expr) (list expr))
  640.    (t
  641.     (nconc (list :begin-list)
  642.            (reduce #'nconc (mapcar #'list-of-tokens expr))
  643.            (list :end-list)))))
  644. (proclaim '(function list-of-tokens (T) list))
  645.  
  646. ;;;--------------------
  647. ;;; Variable Primitives
  648.  
  649. (defmacro DEFVARIABLE (sym)
  650.   "defvariable <sym>                                                   [Macro]
  651.   Interns the name of <sym> in the variable package ?, and exports it.  Use
  652.   to ensure the variable exists before using it in a pattern.  For example,
  653.   (defvariable x) lets us use ?:x as a variable in patterns."
  654.   `(export (intern 
  655.             ,(if (stringp sym) sym (symbol-name sym))
  656.             *?-package*) *?-package*))
  657.  
  658. (defmacro VARIABLE-P (thing)
  659.   "variable-p <thing>                                                  [Macro]
  660.   Returns T iff <thing> is a variable (symbol in the ? package)."
  661.   `(and (symbolp ,thing)
  662.         (eq (symbol-package ,thing) *?-package*)))
  663.   
  664. (defun VARIABLES-IN-PATTERN (pattern)
  665.   "variables-in-pattern <pattern>                                   [Function]
  666.   Returns a list of variables occuring in <pattern>."
  667.   (declare (optimize (safety 1) (space 2) (speed 3)))
  668.   (cond ((null pattern) nil)
  669.         ((atom pattern) (if (variable-p pattern) (list pattern)))
  670.         (T
  671.          (nunion (variables-in-pattern (car pattern))
  672.                  (variables-in-pattern (cdr pattern))))))
  673. (proclaim '(function variables-in-pattern (T) list))
  674.  
  675. (defun PATTERN-P (expr)
  676.   "pattern-p <expr>                                                 [Function]
  677.   Returns non-NIL value iff <expr> is or contains a variable."
  678.   (if (atom expr)
  679.     (variable-p expr)
  680.     (or (pattern-p (first expr)) (pattern-p (rest expr)))))
  681. (proclaim '(function pattern-p (T) T))
  682.  
  683. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  684. ;;; Internal Expression Functions
  685.  
  686. (defun INDEXPR-INTERNAL (expr dnet info)
  687.   (declare (symbol dnet) (optimize (safety 1) (space 2) (speed 3)))
  688.   (let* ((dnet-struct (sm:gets 'dnet dnet))
  689.          (terminal-link (link-to-terminal expr (dnet-link dnet-struct)))
  690.          (dnet-terminal (cdr terminal-link))
  691.          (added (not dnet-terminal))
  692.          (indexpr-hook (dnet-compiled-indexpr-hook dnet-struct)))
  693.     (declare (type dnet dnet-struct) (list terminal-link) (symbol added)
  694.              (type (or null dnet-terminal) dnet-terminal)
  695.              (type (or null function) indexpr-hook))
  696.     (when added
  697.       (setf dnet-terminal (make-dnet-terminal expr info))
  698.       (setf (cdr terminal-link) dnet-terminal)
  699.       (if indexpr-hook (funcall indexpr-hook expr dnet-terminal)))
  700.     (values added dnet-terminal)))
  701. (proclaim '(function indexpr-internal (t symbol t) (values boolean dnet-terminal)))
  702.  
  703. (defun GETEXPR-INTERNAL (expr dnet)
  704.   (declare (symbol dnet) (optimize (safety 1) (space 2) (speed 3)))
  705.   (let* ((dnet-struct (sm:gets 'dnet dnet))
  706.          (dnet-terminal (cdr (find-terminal-link expr (dnet-link dnet-struct)))))
  707.     (declare (type dnet dnet-struct)
  708.              (type (or null dnet-terminal) dnet-terminal))
  709.     (values
  710.      (if dnet-terminal (dnet-terminal-expr dnet-terminal))
  711.      dnet-terminal)))
  712. (proclaim '(function getexpr-internal (t symbol) (values t dnet-terminal)))
  713.  
  714. (defun DELEXPR-INTERNAL (expr dnet)
  715.   (declare (symbol dnet) (optimize (safety 1) (space 2) (speed 3)))
  716.   (let* ((dnet-struct (sm:gets 'dnet dnet))
  717.          (dnet-terminal (unlink-returning-terminal expr (dnet-link dnet-struct)))
  718.          (delexpr-hook  (dnet-compiled-delexpr-hook dnet-struct)))
  719.     (declare (type dnet dnet-struct)
  720.              (type (or null dnet-terminal) dnet-terminal)
  721.              (type (or null function) delexpr-hook))
  722.     (when dnet-terminal
  723.       (if delexpr-hook (funcall delexpr-hook expr dnet-terminal))
  724.       dnet-terminal)))
  725. (proclaim '(function delexpr-internal (t symbol) (or null dnet-terminal)))
  726.  
  727. ;;; NOTE this is used by RULE package.
  728.  
  729. (defmacro EXPR-INFO-INTERNAL (expr dnet)
  730.   `(dnet-terminal-info
  731.     (cdr (find-terminal-link ,expr
  732.                              (dnet-link (the dnet 
  733.                                              (sm:gets 'dnet ,dnet)))))))
  734.  
  735. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  736. ;;;
  737. ;;;                      INTERNAL PATTERN MATCHING CODE
  738. ;;;
  739. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  740.  
  741. (eval-when (compile eval)
  742.   (defmacro CONTINUATIONS-AFTER-PATTERN-VARIABLE (link)
  743.     ;; Returns a list of links reached by consuming one item from <link>.
  744.     ;; The car of <link> has already been consumed, so we are concerned
  745.     ;; with the branches represented by its alist.
  746.     `(let ((alist (cdr ,link)))
  747.        (unless (atom alist)
  748.          (do ((alptr alist (cdr alptr))
  749.               (continuations nil))
  750.              ((null alptr) continuations)
  751.            (declare (list alptr continuations))
  752.            (if (eq (caar alptr) :begin-list)
  753.              (setf continuations
  754.                    (nconc  continuations
  755.                            (the list (continuations-after-consuming-list (car alptr)))))
  756.              (push (car alptr) continuations)))))))
  757.  
  758. (defun CONTINUATIONS-AFTER-CONSUMING-LIST (link)
  759.   ;; Called when <link> has :begin-list as its car, or when processing dotted
  760.   ;; variables, its job is to return a list of links whose cars are the matching 
  761.   ;; :end-lists.
  762.   (declare (list link) (optimize (safety 1) (space 2) (speed 3)))
  763.   (do ((frontier (cdr link))
  764.        (continuations nil))
  765.       ((null frontier) continuations)
  766.     (declare (list frontier continuations))
  767.     ;; A frontier is a point where we are searching a branch for a corresponding
  768.     ;; :end-list.  As long as no new :begin-lists are encountered, the frontier
  769.     ;; is extended just by cdr-ing until :end-list found.  Otherwise recurse.
  770.     (do  ((fptr frontier (cdr fptr))
  771.           (new-frontier nil))
  772.          ((null fptr) (setf frontier new-frontier))
  773.       (declare (list fptr new-frontier))
  774.       (cond
  775.        ;; Found matching endlist: record continuation.
  776.        ((eq (caar fptr) :end-list) (push (car fptr) continuations))
  777.        ;; New list: get recursive continuations, take one step on each to
  778.        ;; knock off recursive :end-lists, yielding new frontier links.
  779.        ((eq (caar fptr) :begin-list)
  780.         (dolist (rcont-link (the list (continuations-after-consuming-list (car fptr))))
  781.           (declare (list rcont-link))
  782.           (setf new-frontier 
  783.                 (append new-frontier (cdr rcont-link))))) ; 1st copied, not 2nd.
  784.        ;; Otherwise move one step down list.
  785.        (T (setf new-frontier
  786.                 (append new-frontier (cdar fptr))))))))
  787. (proclaim '(function continuations-after-consuming-list (list) list))
  788.  
  789. (eval-when (compile eval)
  790.   (defmacro TRAVERSE-LINKS (key frontier)
  791.     ;; Given a search frontier of links, expands that frontier to the links
  792.     ;; reached via the key, pruning any links that can't be traversed.
  793.     `(mapcan 
  794.       #'(lambda (link &aux (new-link nil))
  795.           (declare (list link new-link))
  796.           (if (and (listp (cdr link))
  797.                    (setf new-link (traverse-link ,key link)))
  798.             (list new-link)
  799.             nil))
  800.       ,frontier)))
  801.  
  802. (defun PATTERN-MATCH-LINKS (remaining-pattern frontier)
  803.   ;; Frontier is a list of links called "continuations": these are the 
  804.   ;; locations in the DNET from which we match to the remaining-pattern.
  805.   ;; This function performs a search, where remaining-pattern directs 
  806.   ;; where to go.  The frontier expands when multiple matches to a variable
  807.   ;; in the ARGUMENT is found.  A new list of links (the final frontier)
  808.   ;; is returned.
  809.   (declare (list frontier) (optimize (safety 1) (space 2) (speed 3)))
  810.   (cond 
  811.  
  812.    ;; Remaining pattern is a variable: return list of continuations reached
  813.    ;; by consuming one item from each of the current continuations.
  814.    ((variable-p remaining-pattern)
  815.     (do ((lptr frontier (cdr lptr))
  816.          (new-frontier (list :head)))
  817.         ((null lptr) (cdr new-frontier))
  818.       (declare (list lptr new-frontier))
  819.       (nconc new-frontier 
  820.              (the list (continuations-after-pattern-variable (car lptr))))))
  821.  
  822.    ;; Remaining pattern is an atom: replace each link in the frontier 
  823.    ;; with the link reached after traversing the branch for that atom,
  824.    ;; or eliminate the link's branch from the search frontier if no match.
  825.    ((atom remaining-pattern)
  826.     (traverse-links remaining-pattern frontier))
  827.  
  828.    ;; Remaining pattern is a list.  Traverse a :begin-list token, and 
  829.    ;; iterate over the items in the pattern list, extending the search
  830.    ;; frontier along matching paths until the list is consumed.  Return
  831.    ;; the frontier reached by traversing :end-list links from the result.
  832.    ;; Exception: if the pattern ends in a dotted variable, consume what
  833.    ;; ever is required to finish the list in the DNET.
  834.    (T
  835.     (setf frontier (traverse-links :begin-list frontier))
  836.     (do ((pptr remaining-pattern (cdr pptr)))
  837.         ((atom pptr)
  838.          (if pptr
  839.            (if (variable-p pptr)
  840.              (mapcan #'continuations-after-consuming-list frontier)
  841.              (error "[DNET:MATCH-PATTERN] Nonvariable dotted ending is illegal:~%~S"
  842.                     remaining-pattern))
  843.            (traverse-links :end-list frontier)))
  844.       (declare (list pptr))
  845.       (setf frontier (pattern-match-links (car pptr) frontier))))))
  846. (proclaim '(function pattern-match-links (t list) list))
  847.  
  848. (defun EXPRESSION-MATCH-LINKS (remaining-expression frontier)
  849.   ;; Frontier is a list of links, the locations in the DNET from which
  850.   ;; we match to the remaining-expression.  This function performs a 
  851.   ;; search from frontier, with remaining-expression directing where to go.
  852.   ;; A node in the frontier expands when multiple matches to variables and 
  853.   ;; constants in the NET are found.  A list of links (the "final frontier")
  854.   ;; is returned.
  855.   (declare (list frontier) (optimize (safety 1) (space 2) (speed 3)))
  856.   (let ((new-frontier (list :head)))
  857.     (declare (list new-frontier))
  858.  
  859.     ;; Each link on the frontier represents the last token consumed (the car)
  860.     ;; and where we are now (the cdr).  If the cdr is an alist, it has links
  861.     ;; whose cars are to be matched to the remaining-expression.  If any of
  862.     ;; these cars is a variable, the entire remaining expression is consumed.
  863.     ;; Thus, we may return without further processing the places which matching
  864.     ;; to these variables get us -- namely, the cdrs of the variable links.
  865.     (dolist (flink frontier)
  866.       (declare (list flink))
  867.       (nconc new-frontier
  868.              (mapcan #'(lambda (link)
  869.                          (declare (list link))
  870.                          (if (variable-p (car link)) (list link) nil))
  871.                      (cdr flink))))
  872.  
  873.     ;; Now we have to do literal matching, to be combined with the variable
  874.     ;; continuations computed above.
  875.     (cond 
  876.  
  877.      ;; Atomic expression: For each frontier link, search the continuations
  878.      ;; available in its cdr for a continuing link with an EQUAL atom.  These
  879.      ;; are added to the links to be returned without further processing.
  880.      ((atom remaining-expression)
  881.       (dolist (flink frontier)
  882.         (declare (list flink))
  883.         (nconc new-frontier
  884.                (mapcan #'(lambda (link)
  885.                            (declare (list link))
  886.                            (if (equal (car link) remaining-expression) 
  887.                              (list link)
  888.                              nil))
  889.                        (cdr flink)))))
  890.  
  891.      ;; List expression: In addition to the variable-generated continuations
  892.      ;; computed above, we need to recurse to get the literal matches. Do this
  893.      ;; by expanding the frontier in parallel with iterating over the list.
  894.      (T
  895.       (setf frontier (traverse-links :begin-list frontier))
  896.       (do ((eptr remaining-expression (cdr eptr)))
  897.           ((null eptr) (nconc new-frontier (traverse-links :end-list frontier)))
  898.         (declare (list eptr))
  899.         (setf frontier (expression-match-links (car eptr) frontier)))))
  900.  
  901.     ;; Return all the continuations we have collected.
  902.     (cdr new-frontier)))
  903. (proclaim '(function expression-match-links (t list) list))
  904.  
  905. (defun MATCH-LINKS (remaining-pattern frontier)
  906.   ;; This is the combined version, which processes variables in both the
  907.   ;; remaining-pattern and the dnet.
  908.   (declare (list frontier) (optimize (safety 1) (space 2) (speed 3)))
  909.   (let ((new-frontier (list :head)))
  910.     (declare (list new-frontier))
  911.  
  912.     ;; Each link on the frontier represents the last token consumed (the car)
  913.     ;; and where we are now (the cdr).  If the cdr is an alist, it has links
  914.     ;; whose cars are to be matched to the remaining-pattern.  If any of
  915.     ;; these cars is a variable, the entire remaining expression is consumed.
  916.     ;; Thus, we may return without further processing the places which matching
  917.     ;; to these variables get us -- namely, the cdrs of the variable links.
  918.     (dolist (flink frontier)
  919.       (declare (list flink))
  920.       (nconc new-frontier
  921.              (mapcan #'(lambda (link)
  922.                          (declare (list link))
  923.                          (if (variable-p (car link)) (list link) nil))
  924.                      (cdr flink))))
  925.  
  926.     ;; Now we have to do matching to variables in the pattern, and to literals, 
  927.     ;; to be combined with the dnet variable continuations computed above.
  928.     (cond 
  929.  
  930.      ;; Remaining pattern is a variable: add list of continuations reached
  931.      ;; by consuming one item from each of the current continuations.
  932.      ((variable-p remaining-pattern)
  933.       (do ((lptr frontier (cdr lptr))
  934.            (continuations (list :head)))
  935.           ((null lptr) (nconc new-frontier (cdr continuations)))
  936.         (declare (list lptr continuations))
  937.         (nconc continuations
  938.                (the list (continuations-after-pattern-variable (car lptr))))))
  939.  
  940.      ;; Atomic expression: For each frontier link, search the continuations
  941.      ;; available in its cdr for a continuing link with an EQUAL atom.  These
  942.      ;; are added to the links to be returned without further processing.
  943.      ((atom remaining-pattern)
  944.       (dolist (flink frontier)
  945.         (declare (list flink))
  946.         (nconc new-frontier
  947.                (mapcan #'(lambda (link)
  948.                            (declare (list link))
  949.                            (if (equal (car link) remaining-pattern) 
  950.                              (list link)
  951.                              nil))
  952.                        (cdr flink)))))
  953.  
  954.      ;; List expression: In addition to the variable-generated continuations
  955.      ;; computed above, we need to recurse to get the literal matches. Do this
  956.      ;; by expanding the frontier in parallel with iterating over the list.
  957.      (T
  958.       (setf frontier (traverse-links :begin-list frontier))
  959.       (do ((eptr remaining-pattern (cdr eptr)))
  960.           ((null eptr) 
  961.            (nconc new-frontier (the list (traverse-links :end-list frontier))))
  962.         (declare (list eptr))
  963.         (setf frontier (match-links (car eptr) frontier)))))
  964.  
  965.     ;; Return all the continuations we have collected.  Duplicates arise when
  966.     ;; variables match to variables.
  967.     (delete-duplicates (cdr new-frontier))))
  968. (proclaim '(function match-links (t list) list))
  969.  
  970. ;;; --------------------------------------------------------------------------
  971. ;;; NOTE the next three functions are "internal" but used by the RULE package.
  972. ;;; In particular, previous-bindings is used for consistency filtering.
  973.  
  974. (defun MATCH-PATTERN-INTERNAL (pattern dnet previous-bindings)
  975.   (declare (symbol dnet) (inline pattern-match-links) (list previous-bindings)
  976.            (optimize (safety 1) (space 2) (speed 3)))
  977.   (let ((matching nil) (bindings nil))
  978.     (declare (list matching bindings))
  979.     (dolist (link (the list 
  980.                        (pattern-match-links
  981.                         pattern
  982.                         (list (dnet-link 
  983.                                (the dnet (sm:gets 'dnet dnet)))))))
  984.       (declare (list link))
  985.       (multiple-value-bind 
  986.         (success-p binding)
  987.         (bind-vars pattern (dnet-terminal-expr (cdr link)) previous-bindings)
  988.         (declare (symbol success-p) (list binding))
  989.         (when success-p
  990.           (push (dnet-terminal-expr (cdr link)) matching)
  991.           (push binding bindings))))
  992.     (values matching bindings)))
  993. (proclaim '(function match-pattern-internal (t symbol list) (values list list)))
  994.  
  995. (defun MATCH-EXPRESSION-INTERNAL (expression dnet previous-bindings)
  996.   (declare (inline expression-match-links) (symbol dnet) (list previous-bindings)
  997.            (optimize (safety 1) (space 2) (speed 3)))
  998.   (let ((matching nil) (bindings nil))
  999.     (declare (list matching bindings))
  1000.     (dolist (link (delete-duplicates ; in case expression has variables.
  1001.                    (the list 
  1002.                         (expression-match-links
  1003.                          expression
  1004.                          (list (dnet-link 
  1005.                                 (the dnet (sm:gets 'dnet dnet))))))))
  1006.       (declare (list link))
  1007.       (multiple-value-bind 
  1008.         (success-p binding)
  1009.         (bind-vars (dnet-terminal-expr (cdr link)) expression previous-bindings)
  1010.         (declare (symbol success-p) (list binding))
  1011.         (when success-p
  1012.           (push (dnet-terminal-expr (cdr link)) matching)
  1013.           (push binding bindings))))
  1014.     (values matching bindings)))
  1015. (proclaim '(function match-expression-internal (t symbol list) (values list list)))
  1016.  
  1017. (defun MATCH-INTERNAL (pattern dnet)
  1018.   (declare (symbol dnet) (inline match-links) 
  1019.            (optimize (safety 1) (space 2) (speed 3)))
  1020.   (let ((matching nil) (bindings-1 nil) (bindings-2 nil))
  1021.     (declare (list matching bindings-1 bindings-2))
  1022.     (dolist (link (the list
  1023.                        (match-links pattern
  1024.                                     (list (dnet-link
  1025.                                            (the dnet (sm:gets 'dnet dnet)))))))
  1026.       (declare (list link))
  1027.       (multiple-value-bind
  1028.         (success-p binding-1 binding-2)
  1029.         (unify pattern (dnet-terminal-expr (cdr link)) nil nil)
  1030.         (declare (symbol success-p) (list binding-1 binding-2))
  1031.         (when success-p
  1032.           (push (dnet-terminal-expr (cdr link)) matching)
  1033.           (push binding-1 bindings-1)
  1034.           (push binding-2 bindings-2))))
  1035.     (values matching bindings-1 bindings-2)))
  1036. (proclaim '(function match-internal (t symbol) (values list list list)))
  1037.  
  1038. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1039. ;;;
  1040. ;;;                    EXPORTED OPERATIONS ON DNETs
  1041. ;;;
  1042. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1043.  
  1044. (defun MAKE-DNET (name &key indexpr-hook delexpr-hook info)
  1045.   "make-dnet <name> &key <indexpr-hook> <delexpr-hook> <info>       [Function]
  1046.    Returns a new (empty) discrimination net.  A name is generated unless
  1047.    a symbol <name> is provided.  <Indexpr-hook> and <delexpr-hook> are
  1048.    assumed to be lambda forms of two arguments which may be compiled.
  1049.    These functions are applied to an expression and its corresponding 
  1050.    DNET-TERMINAL the first time it is indexed into or deleted from the 
  1051.    DNET, respectively. If the optional <info> is provided, the DNET's 
  1052.    associated information is initialized to this value."
  1053.   (check-type name symbol)
  1054.   (check-type indexpr-hook list)
  1055.   (check-type delexpr-hook list)
  1056.   (let ((dnet-name (or name (gentemp "DNET-"))))
  1057.     (declare (symbol dnet-name))
  1058.     (create-dnet dnet-name indexpr-hook delexpr-hook info)
  1059.     (setf (dnet-link (the dnet (sm:gets 'dnet dnet-name)))
  1060.           (list dnet-name))
  1061.     (when indexpr-hook
  1062.       (setf (dnet-compiled-indexpr-hook
  1063.              (the dnet (sm:gets 'dnet dnet-name)))
  1064.           (compile nil indexpr-hook)))
  1065.     (when delexpr-hook
  1066.       (setf (dnet-compiled-delexpr-hook
  1067.              (the dnet (sm:gets 'dnet dnet-name)))
  1068.           (compile nil delexpr-hook)))
  1069.     dnet-name))
  1070. (proclaim '(function make-dnet (symbol &key list list t) symbol))
  1071.  
  1072. (defmacro DNET-INFO (dnet)
  1073.   "dnet-info <dnet>                                                    [Macro]
  1074.   Setf-able access to the information associated with <dnet>."
  1075.   `(dnet-info-place (the dnet (sm:gets 'dnet ,dnet))))
  1076.  
  1077. (defun RESET-DNET (dnet &key (indexpr-hook nil)
  1078.                              (delexpr-hook nil)
  1079.                              (info nil info-supplied))
  1080.   "reset-dnet <dnet> &key <indexpr-hook> <delexpr-hook> <info>      [Function]
  1081.   Empties an existing discrimination net.  Also enables one to modify
  1082.   the hooks and associated info.  See MAKE-DNET."
  1083.   (check-type dnet symbol)
  1084.   (check-type indexpr-hook list)
  1085.   (check-type delexpr-hook list)
  1086.   (assert (sm:gets 'dnet dnet) (dnet)
  1087.           "[DNET:RESET-DNET] ~S is not a known DNET." dnet)
  1088.   (setf (dnet-link (the dnet (sm:gets 'dnet dnet))) (list dnet))
  1089.   (when indexpr-hook
  1090.     (setf (dnet-compiled-indexpr-hook (the dnet (sm:gets 'dnet dnet)))
  1091.           (compile nil indexpr-hook)))
  1092.   (when delexpr-hook
  1093.     (setf (dnet-compiled-delexpr-hook (the dnet (sm:gets 'dnet dnet)))
  1094.           (compile nil delexpr-hook)))
  1095.   (when info-supplied (setf (dnet-info dnet) info))
  1096.   dnet)
  1097.  
  1098. (defun DESTROY-DNET (dnet)
  1099.   "destroy-dnet <dnet>                                              [Function]
  1100.   Destroys and undefines the entire <dnet>."
  1101.   (check-type dnet symbol)
  1102.   (assert (sm:gets 'dnet dnet) (dnet)
  1103.           "[DNET:DESTROY-DNET] Unknown DNET ~S" dnet)
  1104.   (sm:destroys 'dnet dnet))
  1105. (proclaim '(function destroy-dnet (symbol) symbol))
  1106.  
  1107. (defvariable expr) ; used below
  1108.  
  1109. (defun ALL-EXPRESSIONS (dnet)
  1110.   "all-expressions <dnet>                                           [Function]
  1111.   Returns a list of all expressions in the indicated <dnet>.  The outer
  1112.   list is constructed fresh and may be hacked.  This is time consuming."
  1113.   (declare (inline pattern-match-links) (optimize (safety 1) (space 2) (speed 3)))
  1114.   (check-type dnet symbol)
  1115.   (assert (sm:gets 'dnet dnet) (dnet)
  1116.           "[DNET:ALL-EXPRESSIONS] Unknown DNET ~S" dnet)
  1117.   ;; I don't use match-pattern-internal since that conses up un-needed bindings.
  1118.   (mapcar #'(lambda (link)
  1119.               (declare (list link))
  1120.               (dnet-terminal-expr (cdr link)))
  1121.           (the list 
  1122.                 (pattern-match-links
  1123.                    '?:expr
  1124.                    (list (dnet-link 
  1125.                             (the dnet (sm:gets 'dnet dnet))))))))
  1126. (proclaim '(function all-expressions (symbol) list))
  1127.  
  1128. (defun MAP-DNET-TERMINALS (f dnet)
  1129.   "map-dnet-terminals <f> <dnet>                                     [Function]
  1130.   Maps <f> across dnet-terminals in the indicated <dnet>.  Returns NIL."
  1131.   (declare (inline pattern-match-links) (optimize (safety 1) (space 2) (speed 3)))
  1132.   (check-type dnet symbol)
  1133.   (assert (sm:gets 'dnet dnet) (dnet)
  1134.           "[DNET:MAP-DNET-TERMINALS] Unknown DNET ~S" dnet)
  1135.   ;; I don't use match-pattern-internal since that conses up un-needed bindings.
  1136.   ;; It is important to ensure that an <f> that calls DELEXPR won't crash this.
  1137.   (map nil #'(lambda (link) (declare (list link)) (funcall f (cdr link)))
  1138.        (the list 
  1139.             (pattern-match-links
  1140.              '?:expr
  1141.              (list (dnet-link 
  1142.                     (the dnet (sm:gets 'dnet dnet))))))))
  1143. (proclaim '(function map-dnet-terminals (function symbol) null))
  1144.  
  1145. (defun SAVE-DNET (dnet path &optional 
  1146.                        (write-in-package *dnet-package*) &aux (vars ()))
  1147.   "save-dnet <dnet> <path> &optional (write-in-package :dnet)       [Function]
  1148.    Saves expressions required to recreate <dnet> to a file at <path>.
  1149.    Returns the <path>.  The file is written in package <write-in-package>,
  1150.    or DNET if the optional argument is unspecified. All associated info
  1151.    is also saved.   Give <vars> a list of known variables.  This function 
  1152.    is slow."
  1153.   (declare (list vars))
  1154.   (check-type dnet symbol)
  1155.   (assert (sm:gets 'dnet dnet) (dnet)
  1156.           "[DNET:SAVE-DNET] Unknown DNET ~S" dnet)
  1157.   (check-type path (or simple-string pathname))
  1158.   (when (not (typep write-in-package 'package))
  1159.     (setf write-in-package (find-package (string write-in-package))))
  1160.   (assert write-in-package (write-in-package) 
  1161.           "[DNET:SAVE-DNET] Bad package specified.")
  1162.   (let ((*package* write-in-package) (*print-pretty* t) (*print-escape* t)
  1163.         (*print-circle* nil) (*print-case* :upcase) (*print-array* t)
  1164.         #+:ccl (ccl::*print-structure* t)
  1165.         (dnet-struct (sm:gets 'dnet dnet))
  1166.         (dnet-terminals
  1167.           (mapcar #'cdr 
  1168.                    (pattern-match-links
  1169.                       '?:expr
  1170.                       (list (dnet-link 
  1171.                                 (the dnet (sm:gets 'dnet dnet))))))))
  1172.     (declare (type dnet dnet-struct) (list dnet-terminals)
  1173.              (optimize (safety 1) (space 2) (speed 3)))
  1174.     (with-open-file (stream path
  1175.                             :direction :output
  1176.                             :if-exists :supersede)
  1177.       (format stream ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1178. ;;; Discrimination Net ~S~%;;; Saved by SAVE-DNET ~A~%;;; On ~A, a ~A"
  1179.               dnet
  1180.               (multiple-value-bind
  1181.                   (second minute hour date month year)
  1182.                   (get-decoded-time)
  1183.                   (declare (integer second minute hour date month year))
  1184.                   (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
  1185.                             date 
  1186.                             (case month
  1187.                                   ((1) "Jan") ((2) "Feb") ((3) "Mar") ((4) "Apr")
  1188.                                   ((5) "May") ((6) "Jun") ((7) "Jul") ((8) "Aug")
  1189.                                   ((9) "Sep") ((10) "Oct") ((11) "Nov") ((12) "Dec"))
  1190.                             (- year 1900)
  1191.                             hour minute second))
  1192.               (machine-instance)
  1193.               (machine-type))
  1194.       (format stream "~%~%(in-package ~S)~%" (package-name write-in-package))
  1195.       (dolist (term dnet-terminals)
  1196.         (declare (simple-vector term)) ; since dnet-terminal is this :type
  1197.         ;; Variables may be in INFO as well as EXPR.  
  1198.         (setf vars 
  1199.               (nunion (nunion (variables-in-pattern (dnet-terminal-expr term)) 
  1200.                               (variables-in-pattern (dnet-terminal-info term)))
  1201.                       vars)))
  1202.       (dolist (v (sort vars #'(lambda (s1 s2) 
  1203.                                 (string< (symbol-name s1) (symbol-name s2)))))
  1204.         (format stream "~%(dnet:defvariable ?::~A)" v))
  1205.       (format stream "~%~%(dnet:make-dnet '~S~
  1206.                       ~%  :indexpr-hook '~A~
  1207.                       ~%  :delexpr-hook '~A~
  1208.                       ~%  :info '~S)~%"
  1209.               dnet
  1210.               (prin1-to-string (dnet-indexpr-hook dnet-struct))
  1211.               (prin1-to-string (dnet-delexpr-hook dnet-struct))
  1212.               (dnet-info-place   dnet-struct))
  1213.       (dolist (term dnet-terminals)
  1214.         (declare (simple-vector term)) ; since dnet-terminal is this :type
  1215.         (format stream "~%(dnet::indexpr-internal '~S '~S '~S)"
  1216.                  (dnet-terminal-expr term) dnet (dnet-terminal-info term)))
  1217.       (format stream "~&~%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1218. ;;; EOF"))
  1219.     path))
  1220. (proclaim '(function save-dnet 
  1221.            (symbol (or simple-string pathname) 
  1222.                    &optional (or null string package))
  1223.            pathname))
  1224.  
  1225. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1226. ;;;
  1227. ;;;                   EXPORTED OPERATIONS ON EXPRESSIONS
  1228. ;;;
  1229. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1230.  
  1231. (defun INDEXPR (expr dnet &optional info)
  1232.   "indexpr <expr> <dnet> &optional <info>                           [Function]
  1233.   Ensures that <expr> is stored in <dnet>.  If the <expr> was not already
  1234.   in <dnet>, initializes the associated information to <info> (if it was 
  1235.   provided), and calls compiled-new-expr-hook (if non-nil) on <expr> and 
  1236.   its dnet-terminal.  The latter allows application-specific processing of 
  1237.   new expressions. Returns two values: the first is a predicate, T iff <expr> 
  1238.   was newly added by this call; and the second is the dnet-terminal structure."
  1239.   (declare (inline indexpr-internal))
  1240.   (assert (not-a-dotted-list expr) (expr)
  1241.           "[DNET:INDEXPR] Dotted lists not allowed in DNET: ~S" expr)
  1242.   (check-type dnet symbol)
  1243.   (assert (sm:gets 'dnet dnet) (dnet)
  1244.           "[DNET:INDEXPR] Unknown DNET ~S" dnet)
  1245.   (indexpr-internal expr dnet info))
  1246. (proclaim '(function indexpr (t symbol &optional t) (values boolean dnet-terminal)))
  1247.  
  1248. (defun GETEXPR (expr dnet)
  1249.   "getexpr <expr> <dnet>                                            [Function]
  1250.   Use to query whether <expr> has been stored in <dnet>, and to obtain the
  1251.   name of its dnet-terminal.  Returns two values: the expression originally
  1252.   stored in <dnet> (and is EQUAL to <expr>), and the dnet-terminal structure.
  1253.   Both values are Nil if <expr> is not found. Variables are not processed."
  1254.   (declare (inline getexpr-internal))
  1255.   (check-type dnet symbol)
  1256.   (assert (sm:gets 'dnet dnet) (dnet) "[DNET:GETEXPR] Unknown DNET ~S" dnet)
  1257.   (getexpr-internal expr dnet))
  1258. (proclaim '(function getexpr (t symbol) (values t dnet-terminal)))
  1259.  
  1260. (defun DELEXPR (expr dnet) 
  1261.   "delexpr <expr> <dnet>                                            [Function]
  1262.   Deletes the expression <expr> from <dnet>, calling DELEXPR-HOOK if it
  1263.   is defined for the DNET.  Returns a DNET-TERMINAL iff it was deleted."
  1264.   (declare (inline delexpr-internal))
  1265.   (check-type dnet symbol)
  1266.   (assert (sm:gets 'dnet dnet) (dnet)
  1267.           "[DNET:DELEXPR] Unknown DNET ~S" dnet)
  1268.   (delexpr-internal expr dnet))
  1269. (proclaim '(function delexpr (t symbol) (or null dnet-terminal)))
  1270.  
  1271. ;;; Had to be a function for safety (multiple evaluation, ...) but need setf.
  1272.  
  1273. (defun EXPR-INFO (expr dnet)
  1274.   "expr-info <expr> <dnet>                                          [Function]
  1275.   Setf-able access to the information associated with <expr> in <dnet>."
  1276.   (check-type dnet symbol)
  1277.   (assert (sm:gets 'dnet dnet) (dnet)
  1278.           "[DNET:EXPR-INFO] Unknown DNET ~S" dnet)
  1279.   (expr-info-internal expr dnet))
  1280. (proclaim '(function expr-info (t symbol) t))
  1281.  
  1282. ;;; Internal users will setf the internal macro directly, but externals need this.
  1283. (defun set-expr-info (expr dnet value)
  1284.   (check-type dnet symbol)
  1285.   (assert (sm:gets 'dnet dnet) (dnet)
  1286.           "[DNET:EXPR-INFO] Unknown DNET ~S" dnet)
  1287.   (setf (expr-info-internal expr dnet) value))
  1288. (defsetf expr-info set-expr-info)
  1289. (proclaim '(function set-expr-info (t symbol t) t))
  1290.  
  1291. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1292. ;;;
  1293. ;;;                    EXPORTED OPERATIONS ON PATTERNS
  1294. ;;;
  1295. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1296.  
  1297. (defun MATCH-PATTERN (pattern dnet)
  1298.   "match-pattern <pattern> <dnet>                                   [Function]
  1299.   For retrieving all expressions matching a pattern which may contain
  1300.   variables.  Returns two values: a list of all expressions in <dnet>
  1301.   matching the <pattern>, and a list of respective unifications.  The
  1302.   latter is a list of lists containing pairs (<pat-var> . <dnet-exp>)
  1303.   representing the binding of <pat-var> to <dnet-exp>, a component of
  1304.   the corresponding returned expression.  Variables in the dnet are 
  1305.   treated as constants.  A special facility provided only by this
  1306.   function is dotted variables: any sublist of <pattern> may end in 
  1307.   a dot followed by a variable.  This is like &rest binding."
  1308.   (declare (inline match-pattern-internal))
  1309.   (check-type dnet symbol)
  1310.   (assert (sm:gets 'dnet dnet) (dnet)
  1311.           "[DNET:MATCH-PATTERN] Unknown DNET ~S" dnet)
  1312.   (match-pattern-internal pattern dnet nil))
  1313. (proclaim '(function match-pattern (t symbol) (values list list)))
  1314.  
  1315. (defun MATCH-EXPRESSION (expression dnet) 
  1316.   "match-expression <expression> <dnet>                             [Function]
  1317.   For retrieving all patterns (which may contain variables) matching an
  1318.   expression.  Returns two values: a list of all patterns in <dnet> 
  1319.   matching the <expression>, and a list of respective unifications.  The
  1320.   latter is a list of lists containing pairs (<exp-part> . <pat-var>) 
  1321.   representing the binding of <pat-var> to <exp-part>, a component of 
  1322.   <expression>. Variables in <expression> are treated as constants."
  1323.   (declare (inline match-expression-internal))
  1324.   (check-type dnet symbol)
  1325.   (assert (sm:gets 'dnet dnet) (dnet)
  1326.           "[DNET:MATCH-EXPRESSION] Unknown DNET ~S" dnet)
  1327.   (match-expression-internal expression dnet nil))
  1328. (proclaim '(function match-expression (t symbol) (values list list)))
  1329.  
  1330. (defun MATCH (pattern dnet)
  1331.   "match <pattern> <dnet>                                           [Function]
  1332.   For retrieving all patterns unifying with a pattern: variables in both
  1333.   are processed.  Returns three values: a list of all patterns in <dnet>
  1334.   unifying with the <pattern>, a list of bindings of variables in <pattern>
  1335.   to those in the matched patterns, and a list of bindings of variables in
  1336.   the matched patterns to those in <pattern>.  The latter two values are
  1337.   lists of lists containing pairs (<var> . <exp>), each representing the
  1338.   binding of <var> to <exp> (ditto).  Note this is less efficient than
  1339.   MATCH-PATTERN and MATCH-EXPRESSION, and should only be used when needed.
  1340.   See also documentation for UNIFY."
  1341.   (declare (inline match-internal))
  1342.   (check-type dnet symbol)
  1343.   (assert (sm:gets 'dnet dnet) (dnet)
  1344.           "[DNET:MATCH] Unknown DNET ~S" dnet)
  1345.   (match-internal pattern dnet))
  1346. (proclaim '(function match (t symbol) (values list list list)))
  1347.  
  1348. (defun BIND-VARS (pattern expression bindings)
  1349.   "bind-vars <pattern> <expression> <bindings>                      [Function]
  1350.   Variables are processed in <pattern> but treated as atoms in <expression>.
  1351.   <Bindings> should be existing bindings (usually nil). Dotted endings in 
  1352.   <pattern> are assumed to be variables, and are processed. Returns two 
  1353.   values: T or NIL to flag whether the pattern matches the expression, and 
  1354.   a list of bindings which achieve this matching."
  1355.   (declare (optimize (safety 1) (space 2) (speed 3)))
  1356.   (cond
  1357.    ;; Variable: See if a previous binding for the variable exists.  If so,
  1358.    ;; the expression must be equal.  Otherwise add the new binding.
  1359.    ((variable-p pattern)
  1360.     (let ((binding (assoc pattern bindings)))
  1361.       (declare (list binding))
  1362.       (if binding
  1363.         (if (equal (cdr binding) expression)
  1364.           (values T bindings)
  1365.           (values nil nil))
  1366.         (values T (push (cons pattern expression) bindings)))))
  1367.  
  1368.    ;; If the pattern is a non-variable atom, then it must be equal to
  1369.    ;; the expression, because the matcher tests for this.
  1370.    ((atom pattern) (values T bindings))
  1371.  
  1372.    ;; Otherwise both are lists: iterate over items in lists in parallel
  1373.    ;; (avoiding double recursion, empirically faster), seeing if the
  1374.    ;; corresponding items bind, and adding any necessary bindings.
  1375.    (T ; Allegro Common Lisp won't return two values if DO put first.
  1376.     (do ((pattern-ptr pattern (cdr pattern-ptr)) 
  1377.          (expression-ptr expression (cdr expression-ptr)))
  1378.         ;; Matcher guarantees the lists are the same length; don't have
  1379.         ;; to test (null expression-ptr).
  1380.         ((null pattern-ptr) (values T bindings))
  1381.       (declare (list pattern-ptr expression-ptr))
  1382.       (if (atom pattern-ptr) ; won't be nil
  1383.         (let ((binding (assoc pattern-ptr bindings)))
  1384.           (declare (list binding))
  1385.           (if binding
  1386.             (if (not (equal (cdr binding) expression-ptr))
  1387.               (return (values nil nil))  ; blow out of loop
  1388.               (setf pattern-ptr    nil
  1389.                     expression-ptr nil)) ; exit normally next pass
  1390.             (progn
  1391.               (push (cons pattern-ptr expression-ptr) bindings)
  1392.               (setf pattern-ptr nil))))
  1393.         (multiple-value-bind
  1394.           (success-p new-bindings)
  1395.           (bind-vars (car pattern-ptr) (car expression-ptr) bindings)
  1396.           (declare (symbol success-p) (list new-bindings))
  1397.           (if success-p
  1398.             (setf bindings new-bindings)
  1399.             (return (values nil nil)))))))))
  1400. (proclaim '(function bind-vars (t t list) (values boolean list)))
  1401.  
  1402. (defun SUBSTITUTE-BINDINGS (bindings pattern)
  1403.   "substitute-bindings <bindings> <pattern>                         [Function]
  1404.   Given <bindings> is an association list as returned by one of the match
  1405.   functions, creates an expression from <pattern> where all the variables
  1406.   have been replaced by their bindings.  New list structure is used.
  1407.   Only makes one pass -- see substitute-transitive-bindings if variables
  1408.   may be bound to each other."
  1409.   (check-type bindings list)
  1410.   (labels ((substitute-bindings-r (bindings pattern &aux binding)
  1411.          (declare (list bindings binding) 
  1412.                       (optimize (safety 1) (space 2) (speed 3)))
  1413.          (cond ((null pattern) nil)
  1414.            ((atom pattern)
  1415.             (if (and (variable-p pattern)
  1416.                  (setf binding (assoc pattern bindings)))
  1417.               (cdr binding)
  1418.               pattern))
  1419.            (t
  1420.             (cons (substitute-bindings-r bindings (car pattern))
  1421.               (substitute-bindings-r bindings (cdr pattern)))))))
  1422.     (substitute-bindings-r bindings pattern)))
  1423. (proclaim '(function substitute-bindings (list t) t))
  1424.  
  1425. (defun SUBSTITUTE-TRANSITIVE-BINDINGS (bindings pattern)
  1426.   "substitute-bindings <bindings> <pattern>                         [Function]
  1427.   Given <bindings> is an association list as returned by one of the match
  1428.   functions, creates an expression from <pattern> where all the variables
  1429.   have been replaced by their bindings.  New list structure is used.  
  1430.   Makes as many passes are needed to eliminate transitivities which may
  1431.   be returned by UNIFY when both patterns have variables, such as 
  1432.   ((?:y . 3) (?:x . ?:y)) which unifies (?:x ?:x) and (?:y 3)."
  1433.   (check-type bindings list)
  1434.   (let ((changed nil))
  1435.     (labels ((substitute-bindings-r (bindings pattern &aux binding)
  1436.                 (declare (list bindings binding)
  1437.                          (optimize (safety 1) (space 2) (speed 3)))
  1438.                 (cond ((null pattern) nil)
  1439.                       ((atom pattern)
  1440.                        (if (and (variable-p pattern)
  1441.                                 (setf binding (assoc pattern bindings)))
  1442.                          (progn (setq changed t) (cdr binding))
  1443.                          pattern))
  1444.                       (t
  1445.                        (cons (substitute-bindings-r bindings (car pattern))
  1446.                              (substitute-bindings-r bindings (cdr pattern)))))))
  1447.       (let ((new-pattern (substitute-bindings-r bindings pattern)))
  1448.         (if changed 
  1449.           (substitute-transitive-bindings bindings new-pattern)
  1450.           new-pattern)))))
  1451. (proclaim '(function substitute-transitive-bindings (list t) t))
  1452.  
  1453. (defun UNIFY (pattern-1 pattern-2 &optional (bindings-1 nil) (bindings-2 nil))
  1454.   "unify <pattern-1> <pattern-2> &optional <bindings-1> <bindings-2> [Function]
  1455.   Given two list/atom patterns (each of which may contain variables), and
  1456.   a (usually nil) set of initial bindings, returns three values: 
  1457.     1. T or NIL to flag whether the patterns unify;
  1458.     2. Bindings of variables in <pattern-1> to elements of <pattern-2>;
  1459.     3. Bindings of variables in <pattern-2> to elements of <pattern-1>.
  1460.   (The flag is returned first so UNIFY can be used as a predicate.  Since 
  1461.   unification can succeed with no bindings, the other values will not serve 
  1462.   this function.)  Example:
  1463.     (unify '(a ?:x c) '(a (b) ?:y)) ==> T; ((?:X B)); ((?:Y . C))
  1464.   Transitivity of bindings is not used for simplification, e.g. you could
  1465.   get back T; ((?:X . ?:Y)); ((?:Y . C)). Modified from version by Ken Forbus.
  1466.   This function is logically general, and hence checks for a variety of 
  1467.   conditions.  It may be inefficient for specialized tasks: I recommend 
  1468.   writing a specialized version if any assumptions may be made about the
  1469.   patterns to be unified."
  1470.   (declare (list bindings-1 bindings-2) (optimize (safety 1) (space 2) (speed 3)))
  1471.  
  1472.   (cond ((equal pattern-1 pattern-2) (values t bindings-1 bindings-2))
  1473.         ((variable-p pattern-1) 
  1474.          (unify-variable-1 pattern-1 pattern-2 bindings-1 bindings-2))
  1475.         ((variable-p pattern-2) 
  1476.          (unify-variable-2 pattern-1 pattern-2 bindings-1 bindings-2))
  1477.         ((or (not (listp pattern-1)) (not (listp pattern-2))) 
  1478.          (values nil nil nil))
  1479.         (t
  1480.          (multiple-value-bind
  1481.            (success new-bindings-1 new-bindings-2)
  1482.            (unify (first pattern-1) (first pattern-2) bindings-1 bindings-2)
  1483.            (if success 
  1484.              (unify (rest pattern-1) (rest pattern-2) new-bindings-1 new-bindings-2)
  1485.              (values nil nil nil))))))
  1486. (proclaim '(function unify (T T &optional list list) (values boolean list list)))
  1487.  
  1488. ;;; These three were lexically scoped in UNIFY, but the VAX compile warned of
  1489. ;;; "not declared or defined" (I suppose you have to declare lexically scoped
  1490. ;;; functions as such?).  Besides, tests show lexical scoping is slower!!!
  1491.  
  1492. (defun FREE-IN? (variable pattern bindings)
  1493.   ;; Determines whether a variable is free in a pattern.
  1494.   (cond ((null pattern) t)
  1495.         ((eq variable pattern) nil)
  1496.         ((variable-p pattern)
  1497.          (free-in? variable (utils:image pattern bindings) bindings))
  1498.         ((not (listp pattern)) t)
  1499.         ((free-in? variable (first pattern) bindings)
  1500.          (free-in? variable (rest pattern) bindings))))
  1501.  
  1502. (defun UNIFY-VARIABLE-1 (variable pattern bindings-1 bindings-2 &aux value)
  1503.   ;; Deals with case where pattern-1 is a variable.
  1504.   (cond ((setq value (utils:image variable bindings-1))
  1505.          (unify value pattern bindings-1 bindings-2))
  1506.         ((free-in? variable pattern bindings-2)
  1507.          (values t (cons (cons variable pattern) bindings-1) bindings-2))
  1508.         (t (values nil nil nil))))
  1509.  
  1510. (defun UNIFY-VARIABLE-2 (pattern variable bindings-1 bindings-2 &aux value)
  1511.   ;; Deals with case where pattern-2 is a variable.
  1512.   (cond ((setq value (utils:image variable bindings-2))
  1513.          (unify pattern value bindings-1 bindings-2))
  1514.         ((free-in? variable pattern bindings-1)
  1515.          (values t bindings-1 (cons (cons variable pattern) bindings-2)))
  1516.         (t (values nil nil nil))))
  1517.  
  1518. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1519. (provide :DNET)
  1520. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1521. ;;; EOF
  1522.    
  1523.